COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00004 00003	! 	ttysave,file_string
C00006 00004	! input/output:      altf,altrans,alframe,aldec,al_subtree,alid
C00011 00005	! i/o: writecode
C00013 ENDMK
C⊗;
ENTRY;
BEGIN "OUTPUT"

DEFINE $OUTPUT=TRUE;

REQUIRE "HEADER.SAI" SOURCE_FILE;

EXTERNAL INTEGER PROCEDURE UGETF(INTEGER CHAN);
EXTERNAL INTEGER PROCEDURE UGET(INTEGER CHAN);

RCLASS FILE_LIST(STRING FILE; RPTR(FILE_LIST)NEXT);
RPTR(FILE_LIST)FLIST;

STRING PROCEDURE STD_FILENAME(STRING S);
BEGIN
	INTEGER EXTEN,PPN,F;
	F←CVFIL(S,EXTEN,PPN);
	RETURN(CVXSTR(F)&"."&CVXSTR(EXTEN)[1 TO 3]&"["&CVXSTR(PPN)[1 TO 3]&","
			&CVXSTR(PPN)[4 TO 6]&"]");
END;

BOOLEAN PROCEDURE USED_BEFORE(STRING FILE);
BEGIN
	RPTR(FILE_LIST)PTR; STRING S;
	PTR←FLIST; S←STD_FILENAME(FILE);
	WHILE PTR DO
		IF EQU(S,FILE_LIST:FILE[PTR])
		THEN RETURN(TRUE) ELSE PTR←FILE_LIST:NEXT[PTR];
	RETURN(FALSE);
END;


PROCEDURE ADD_USED_LIST(STRING FILE);
BEGIN
	RPTR(FILE_LIST)PTR; STRING S;
	PTR←FLIST; S←STD_FILENAME(FILE);
	WHILE PTR DO
		IF EQU(S,FILE_LIST:FILE[PTR])
		THEN RETURN ELSE PTR←FILE_LIST:NEXT[PTR];
	PTR←NEW_RECORD(FILE_LIST);
	FILE_LIST:FILE[PTR]←S;
	FILE_LIST:NEXT[PTR]←FLIST;
	FLIST←PTR;
END;
! 	ttysave,file_string;
INTERNAL PROCEDURE TTYSAVE(STRING FILE);
	BEGIN
	INTEGER OLD$TTYCH;
	OLD$TTYCH←$TTYCH;
	IF not $OUT THEN $TTYCH←ORAFILE(FILE)
	ELSE IF NOT EQU(STD_FILENAME(FILE),STD_FILENAME($TTYFL))
		THEN BEGIN
		    $TTYCH←ORAFILE(FILE);	! note if fails doesnt return ;
		    CRAFILE(OLD$TTYCH);
		    END;
	$TTYFL←FILE;
	$OUT←TRUE;
	$OULST←NULL;
	OUT($TTYCH,FF&"{ FILE being written by POINTY: "&DAT_STR&"}"&CRLF);
	END;

	! returns a string with the names of files used for output ;
INTERNAL STRING PROCEDURE FILE_STRING;
	BEGIN
	STRING TS; TS←NULL;
	IF $OUT THEN TS←"*"&$TTYFL;
	TS←CRLF&" "&$ALFL;
	RETURN(TS);
	END;

! input/output:      altf,altrans,alframe,aldec,al_subtree,alid;

	! returns frame declaration and assignment
	  of affixment for the frame pointed by nd. If the frame is affixed 
	  independently an assignment instruction is generated, otherwhise an
	  affix instruction, with the correct type of affixment is produced;

STRING PROCEDURE ALDEC(RPTR(FRAME) ND);
	BEGIN
	STRING NAME,DS,FS;
 	NAME←FRAME:PNAME[ND];				! frame pname;
	IF SYMBOL:ACCESS[FRAME:SYM[ND]]≠#ARRAY_ELEMENT
		THEN DS←"FRAME "&NAME&";"&CRLF
		ELSE DS←NULL;
 	IF FRAME:HOWLINKED[ND]=#INDLK
	   THEN FS←NAME&" ← "&CVSYM(FRAME:SYM[ND],FILE_D)&";"&DLF
	   ELSE BEGIN
        	FS←"AFFIX "&NAME&" TO "&FRAME:PNAME[FRAME:DAD[ND]]&" AT"
			&CRLF&$BLANK[1 TO 6]&"TRANS"&CVSYM(FRAME:SYM[ND],FILE_D)[6 TO ∞];
		IF FRAME:HOWLINKED[ND]=#NRGLK
		   THEN FS←FS&" NONRIGIDLY;"&DLF
		   ELSE FS←FS&" RIGIDLY;"&DLF;
		END;
	RETURN(DS&FS);
	END;

STRING PROCEDURE MC_OUT(RPTR(SYMBOL) EEE);
	BEGIN 
	STRING MS;
	MS←"DEFINE "&MACRO:HEAD[SYMBOL:OBJECT[EEE]]&" = "&CVSYM(EEE)&";"&DLF;
	RETURN(MS);
	END;

STRING PROCEDURE PR_OUT(RPTR(SYMBOL) EEE);
	BEGIN
	STRING PS;
	PS←CVSYM(EEE)&DLF;
	RETURN(PS);
	END;

STRING RECURSIVE PROCEDURE FR_OUT(RPTR(FRAME) ND);
	BEGIN
	RPTR(FRAME) SN; STRING S,RSTRING;
	RSTRING←NULL;
	IF NOT(ND=F_WRLD OR EQU(S←FRAME:PNAME[ND],"BPARK")
		OR EQU(S,"YPARK") OR EQU(S,"BARM")OR EQU(S,"YARM")
		OR EQU(S,"BGRASP"))
		THEN RSTRING←ALDEC(ND);
	SN←FRAME:SON[ND];
	WHILE SN≠NULL_RECORD 
	     DO	BEGIN
		RSTRING←RSTRING&FR_OUT(SN);
	 	SN←FRAME:EBRO[SN];
		END;
	RETURN(RSTRING);
	END;

PRELOAD_WITH "SCALAR ","DISTANCE VECTOR ","ROT ","TRANS ","FRAME ";
STRING ARRAY DTYPES[#SC:#FR];

STRING PROCEDURE EL_OUT(RPTR(SYMBOL)ADDR);
	BEGIN
	STRING DS,VS;
	DS←DTYPES[SYMBOL:TYPE[ADDR]]&" "&SYMBOL:PNAME[ADDR]&";"&CRLF;
	VS←SYMBOL:PNAME[ADDR]&" ← "& CVSYM(ADDR,FILE_D)&";"&DLF;
	RETURN(DS&VS);
	END;

STRING PROCEDURE ARR_OUT(RPTR(SYMBOL)ADDR);
	BEGIN
	RPTR(ARRAYREC) ARRREC;
	STRING DS,VS;
	INTEGER I,#DIM;
	$EVLARR(ADDR);
	DS←DTYPES[SYMBOL:TYPE[ADDR]]&"ARRAY "&SYMBOL:PNAME[ADDR]&"[";
	ARRREC←SYMBOL:OBJECT[ADDR];
	FOR I←1 STEP 1 UNTIL (#DIM←ARRAYREC:#DIM[ARRREC]) DO
		DS←DS&CVS(ARRAYREC:LB[ARRREC][I])&":"
			&CVS(ARRAYREC:UB[ARRREC][I])&",";
	DS←DS[1 TO INF - 1]&"];"&CRLF;
	VS←NULL;
	FOR I←1 STEP 1 UNTIL ARRAYREC:#EL[ARRREC] DO
		VS←VS&SYMBOL:PNAME[ARRAYREC:PTR[ARRREC][I]]&"←"
			&CVSYM(ARRAYREC:PTR[ARRREC][I],FILE_D)
			&";"&CRLF;
	RETURN(DS&VS&CRLF);
	END;

STRING PROCEDURE ST_OUT(INTEGER TYPE);
	BEGIN "U" INTEGER I;
	STRING S; S←NULL;
	CASE TYPE OF
	    BEGIN "CASE"
		  [#SC] [#VT][#RT][#TR]
			FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL
				$ENTRY[TYPE] DO
				IF SYMBOL:ACCESS[$YMTAB[TYPE,I]]=#ARRAY
				    THEN S←S&ARR_OUT($YMTAB[TYPE,I])
				    ELSE S←S&EL_OUT($YMTAB[TYPE,I]);
		  [#FR] S←FR_OUT(SYMBOL:OBJECT[WORLD]);
		  [#PR] FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
				S←S&PR_OUT($YMTAB[TYPE,I]);
		  [#MC] FOR I←OFFSET[RES_OFFSET,TYPE]+1 STEP 1 UNTIL $ENTRY[TYPE] DO
				S←S&MC_OUT($YMTAB[TYPE,I])
		END "CASE";
	RETURN(S);
	END "U";
! i/o: writecode;

INTERNAL PROCEDURE WRITECODE(STRING FILE;RPTR(SYMBOL) ELEMENT);
	BEGIN
	STRING DATA_STRING;
	INTEGER I;
	DATA_STRING←NULL;
	IF ELEMENT=NULL_RECORD
	THEN FOR I←#SC,#VT,#RT,#TR,#FR,#MC,#PR DO
		 DATA_STRING←DATA_STRING&ST_OUT(I)
	ELSE IF SYMBOL:ACCESS[ELEMENT]=#ARRAY THEN
		DATA_STRING←ARR_OUT(ELEMENT)
	ELSE CASE SYMBOL:TYPE[ELEMENT] OF
	     BEGIN
		[#SC][#VT][#RT][#TR]
			DATA_STRING←EL_OUT(ELEMENT);
		[#FR] DATA_STRING←FR_OUT(SYMBOL:OBJECT[ELEMENT]);
		[#MC] DATA_STRING←MC_OUT(ELEMENT);
		[#PR] DATA_STRING←PR_OUT(ELEMENT)
	     END;
	IF NOT USED_BEFORE(FILE) THEN
		DATA_STRING←FF&"{FILE being written by POINTY on "&DAT_STR&"}"
			&CRLF&DATA_STRING;
	ADDFILE(FILE,DATA_STRING);
	ADD_USED_LIST(FILE); $ALFL←FILE;
	END;
END "OUTPUT";